home *** CD-ROM | disk | FTP | other *** search
/ Macwelt 1 / Macwelt DVD 1.toast / Web-Publishing / HTML-Editoren / Alpha ƒ / Tcl / SystemCode / modes.tcl < prev    next >
Encoding:
Text File  |  2001-02-07  |  15.9 KB  |  584 lines
  1. # (nowrap)
  2. #  AlphaTcl - core Tcl engine
  3.  
  4. namespace eval mode {}
  5. namespace eval win {}
  6. namespace eval menu {}
  7.  
  8. # ◊◊◊◊ Declare Alpha packages ◊◊◊◊ #
  9.  
  10. # This procedure is not yet final.  Please do not rely on its API for
  11. # use outside of Alpha's core.  Changes may be made to streamline Alpha's
  12. # package initialisation and declaration process.
  13. proc alpha::declare {what name version modes {initialise ""} {activate ""} {deactivate ""} args} {
  14.     global alpha::rebuilding
  15.     if {!${alpha::rebuilding}} {return}
  16.     global index::feature rebuild_cmd_count index::flags
  17.     if {[string trim "$initialise$activate$deactivate"] == ""} {
  18.     set index::feature($name) [list $version $modes -1]
  19.     } else {
  20.     switch -- $what {
  21.         "feature" {
  22.         set init 0
  23.         }
  24.         "menu" {
  25.         set init 1
  26.         }
  27.         "flag" {
  28.         set init 2
  29.         lappend index::flags $name
  30.         }
  31.         "autofeature" {
  32.         set init 3
  33.         }
  34.         default {
  35.         error "Bad alpha::declare type '$what'"
  36.         }
  37.     }
  38.     set index::feature($name) [list $version $modes $init $initialise $activate $deactivate]
  39.     }
  40.     if {[llength $args]} {
  41.     eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  42.     return
  43.     }
  44.     if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  45.     return -code 11
  46.     }
  47. }
  48.  
  49. proc alpha::feature {name version modes {initialise ""} {activate ""} {deactivate ""} args} {
  50.     uplevel 1 [list alpha::declare feature $name $version $modes \
  51.       $initialise $activate $deactivate] $args
  52. }
  53.  
  54. proc alpha::flag {name version prefsPage modes args} {
  55.     if {[string length $prefsPage]} {
  56.     set init "set $name 0 ; lappend flagPrefs($prefsPage) $name"
  57.     } else {
  58.     set init "set $name 0"
  59.     }
  60.     uplevel 1 [list alpha::declare flag $name $version $modes \
  61.       $init "set $name 1" "set $name 0"] $args
  62. }
  63.  
  64. proc alpha::extension {name version {script ""} args} {
  65.     uplevel 1 [list alpha::declare feature $name $version "global-only" "" $script ""] $args
  66. }
  67.  
  68. proc alpha::menu {name version modes {value ""} {initialise ""} {activate ""} {deactivate ""} args} {
  69.     global alpha::rebuilding
  70.     if {!${alpha::rebuilding}} {
  71.     # This is required when autoloading some procs without activating
  72.     # a menu
  73.     global $name
  74.     ensureset $name $value
  75.     return
  76.     }
  77.     if {[regexp {^•} [string index $modes 0]]} {
  78.     # it's in the old format
  79.     set tmp $modes
  80.     set modes $value
  81.     if {$modes == "in_menu"} { set modes "global" }
  82.     set value $tmp
  83.     # perhaps there's a better way of collapsing these arguments
  84.     if {[llength $args]} {
  85.         set args [concat [list $activate $deactivate] $args]
  86.     } else {
  87.         if {$deactivate != ""} {
  88.         lappend activate $deactivate
  89.         set args $activate
  90.         } else {
  91.         set args $activate
  92.         }
  93.     }    
  94.     set activate "$name"
  95.     set deactivate ""
  96.     }
  97.     uplevel 1 [list alpha::declare menu $name $version $modes \
  98.       "ensureset $name $value\n$initialise" $activate $deactivate] $args
  99. }
  100.  
  101. proc alpha::mode {name version dummyProc {ext ""} {menus ""} {script ""} args} {
  102.     global alpha::rebuilding alpha::requirements pkg_file
  103.     if {!${alpha::rebuilding}} {return}
  104.     namespace eval ::$name {}
  105.     global index::mode rebuild_cmd_count index::oldmode
  106.     if {$dummyProc == "source"} {
  107.     # We could use 'info script' instead of pkg_file, except
  108.     # for encoding purposes we might not be using 'source' to source files.
  109.     set dummyProc [alpha::actionOnFileScript source $pkg_file]
  110.     }
  111.     # We need to convert the 'list' $ext into a real list in which 
  112.     # there are no newline, etc characters.
  113.     set exts [list]
  114.     foreach e $ext {
  115.     lappend exts $e
  116.     }
  117.     if {[info exists index::mode($name)]} {
  118.     dialog::alert "You have a duplicate definition of $name mode,\
  119.       possibly in the file [info script].  This is likely to lead\
  120.       to problems, in which this new definition partially or completely\
  121.       overrides the original.  You should remove one of the definitions."
  122.     }
  123.     set index::mode($name) [list $version $dummyProc $exts $menus $script]
  124.     if {[info exists index::oldmode($name)]} {
  125.     if {[set omenus [lindex [set index::oldmode($name)] 3]] != $menus} {
  126.         global alpha::noMenusYet mode::features modifiedArrayElements
  127.         if {![info exists mode::features($name)]} {set mode::features($name) ""}
  128.         foreach m $menus {
  129.         # Store all version number requirements
  130.         if {[lindex $m 2] != ""} {
  131.             lappend alpha::requirements [list $name $m]
  132.         }
  133.         set mm [lindex $m 0]
  134.         if {([lsearch -exact $omenus $mm] == -1) \
  135.           && ([lsearch -glob $omenus "$mm *"] == -1)} {
  136.             # it's new
  137.             package::addRelevantMode $mm $name
  138.             if {[lindex $m 1] == 0} {continue}
  139.             if {[info exists alpha::noMenusYet]} {
  140.             # we added a feature 
  141.             hook::register startupHook "lunion mode::features($name) $mm"
  142.             } else {
  143.             lunion mode::features($name) $mm
  144.             lappend modifiedArrayElements [list $name mode::features]
  145.             }
  146.         }
  147.           
  148.         }
  149.         foreach om $omenus {
  150.         set omm [lindex $om 0]
  151.         if {([lsearch -exact $menus $omm] == -1) \
  152.           && ([lsearch -glob $menus "$omm *"] == -1)} {
  153.             # it has been removed from the default list
  154.             package::removeRelevantMode $omm $name
  155.             set mode::features($name) [lremove [set mode::features($name)] $omm]
  156.             lappend modifiedArrayElements [list $name mode::features]
  157.         }
  158.         }
  159.     }
  160.     }
  161.     if {[llength $args]} {
  162.     eval alpha::package [lindex $args 0] $name $version [lrange $args 1 end]
  163.     return
  164.     }
  165.     if {[info exists rebuild_cmd_count] && [incr rebuild_cmd_count -1] == 0} {
  166.     return -code 11
  167.     }        
  168. }
  169.  
  170. ## 
  171.  # -------------------------------------------------------------------------
  172.  # 
  173.  # "addMode" -- you probably won't call this proc yourself
  174.  # 
  175.  # -------------------------------------------------------------------------
  176.  ##
  177. proc addMode {m dummy suffs _features} {
  178.     global mode::features filepats dummyProc index::feature
  179.     namespace eval ::$m {}
  180.     if {[string length $dummy]} {set dummyProc($m) $dummy}
  181.     ensureset mode::features($m) $_features
  182.     foreach f $_features {
  183.     package::addRelevantMode $f $m
  184.     }
  185.     ensureset filepats($m) $suffs
  186. }
  187.  
  188. proc addMenu {name {val ""} {modes ""} {helpText ""}} {
  189.     global menus index::feature index::help
  190.     lunion menus $name
  191.     if {$val != ""} {
  192.     global $name
  193.     if {![info exists $name]} { set $name $val }
  194.     }
  195.     if {[info exists index::feature($name)]} {
  196.     eval lappend modes [lindex [set index::feature($name)] 1]
  197.     }
  198.     set index::feature($name) \
  199.       [list [list "mode" [lindex $modes 0]] $modes 1 "" $name ""]
  200.     set index::help($val) $helpText
  201. }
  202.  
  203.  
  204. # ◊◊◊◊ Procs Alpha calls directly ◊◊◊◊ #
  205. proc getModeValuesAlpha {} {
  206.     global showInvisibles
  207.     
  208.     getWinInfo blah
  209.     lappend m "Mac" [expr {$blah(platform) == "mac"}]
  210.     lappend m "UNIX" [expr {$blah(platform) == "unix"}]
  211.     lappend m "IBM" [expr {$blah(platform) == "ibm"}] {(-} 0
  212.     lappend m "MPW" [expr {$blah(state) == "mpw"}]
  213.     lappend m "Think" [expr {$blah(state) == "think"}]
  214.     lappend m "None" [expr {$blah(state) == "none"}] {(-} 0
  215.     lappend m "Read Only" $blah(read-only)
  216.     lappend m "Show Invisibles" $showInvisibles {(-} 0
  217.     lappend m "Tab Size" 0
  218.     return $m
  219. }
  220.  
  221.  
  222. proc setModeVarAlpha {var} {
  223.     global mode allFlags modeVars
  224.     global ${mode}modeVars
  225.     
  226.     set var [string tolower $var]
  227.     switch -- $var {
  228.         "unix"      -
  229.         "mac"       -
  230.         "ibm"       { setWinInfo platform $var ; setWinInfo dirty 1 }
  231.         "mpw"       -
  232.         "think"     -
  233.         "none"      { setWinInfo state $var }
  234.         "tab size"  {
  235.             getWinInfo arr
  236.             if {![catch {prompt "New tab size?" $arr(tabsize)} res]} {
  237.                 setWinInfo tabsize $res
  238.             }
  239.         }
  240.         "read only" { 
  241.             getWinInfo b
  242.             setWinInfo read-only [expr {-1 * ($b(read-only) - 1)}]}
  243.         "show invisibles" { 
  244.             global showInvisibles
  245.             set showInvisibles [expr {1 - $showInvisibles}]
  246.         }
  247.     }
  248.     return
  249. }
  250.  
  251. ## 
  252.  # -------------------------------------------------------------------------
  253.  # 
  254.  # "modes" --
  255.  # 
  256.  #  Called to get the list of modes for the modes popup
  257.  # -------------------------------------------------------------------------
  258.  ##
  259. proc modes {args} { 
  260.     return [mode::listAll]
  261. }
  262.  
  263. # Called from alpha in response to the mode popup.
  264. proc newMode {newMode} {
  265.     if {[package::helpOrDescribe $newMode]} { return }
  266.     global win::Modes
  267.     changeMode $newMode
  268.     if {[catch {win::Current} name]} return
  269.     set win::Modes($name) $newMode
  270.     refresh
  271. }
  272.  
  273. # ◊◊◊◊ Mode specific items ◊◊◊◊ #
  274.  
  275. proc mode::listAll {} {
  276.     global mode::features
  277.     return [lsort -ignore [array names mode::features]]
  278. }
  279.  
  280. proc mode::exists {m} {
  281.     global mode::features
  282.     info exists mode::features($m)
  283. }
  284.  
  285. proc mode::removeFeatureFromAll {f} {
  286.     global mode::features
  287.     foreach m [array names mode::features] {
  288.     if {[set idx [lsearch -exact [set mode::features($m)] $f]] >= 0} {
  289.         set mode::features($m) [lreplace [set mode::features($m)] $idx $idx]
  290.         prefs::modified mode::features($m)
  291.     }
  292.     }
  293. }
  294.  
  295. proc mode::getFeatures {m} {
  296.     global mode::features
  297.     set mode::features($m)
  298. }
  299.  
  300. proc mode::adjustFeatures {f {add 1}} {
  301.     global mode::features mode
  302.     set idx [lsearch -exact [set mode::features($mode)] $f]
  303.     if {$add} {
  304.     if {$idx < 0} {
  305.         lappend mode::features($mode) $f
  306.         package::activate $f
  307.         prefs::modified mode::features($mode)
  308.     }
  309.     } else {
  310.     if {$idx >= 0} {
  311.         set mode::features($mode) [lreplace [set mode::features($mode)] $idx $idx]
  312.         package::deactivate $f
  313.         prefs::modified mode::features($mode)
  314.     }
  315.     }
  316. }
  317.  
  318. proc mode::isFeatureActive {m f} {
  319.     global mode::features
  320.     return [expr {[lsearch -exact [set mode::features($m)] $f] != -1}]
  321. }
  322.  
  323. proc mode::menuProc {menu item} {
  324.     if {![llength [winNames -f]]} {
  325.         alertnote "Mode operations require a current mode, and hence\
  326.       a current window."
  327.         return
  328.     }
  329.     switch -- $item {
  330.         "preferences"       dialog::modifyModeFlags
  331.         "loadPrefsFile"     mode::sourcePrefsFile
  332.         "describeMode"      mode::describe
  333.         "changeMode"        mode::changeDialog
  334.     default {
  335.         mode::$item
  336.     }        
  337.     }
  338. }
  339.  
  340.  
  341. proc mode::changeDialog {} {
  342.     global mode
  343.     newMode [listpick -p "Mode:" -L $mode [mode::listAll]]
  344. }
  345.  
  346. proc mode::describe {} {
  347.     global mode ModeSuffixes mode::features
  348.     global ${mode}modeVars
  349.     
  350.     set text "\r\tMODE $mode\r\r"
  351.     if {![catch {package::describe $mode 1} res]} {
  352.     append text $res "\r\r"
  353.     }
  354.  
  355.     set tmp ""
  356.     catch {set tmp [package::helpFile $mode 1]}
  357.     append text "$tmp\r\r"
  358.  
  359.     set suffs ""
  360.     foreach suf $ModeSuffixes {
  361.         if {([llength $suf] == 3) && ([lindex $suf 1] == "winMode") \
  362.       && ([lindex $suf 2] == $mode)} {
  363.         lappend suffs $last
  364.         }
  365.         set last $suf
  366.     }
  367.     append text "Mode filepats: " [join $suffs ", "] "\r\r"
  368.     
  369.     append text "Mode menus and features: "
  370.     if {[info exists mode::features($mode)]} {
  371.     append text [join [set mode::features($mode)] ", "]
  372.     }
  373.     append text "\r\r"
  374.     append text [mode::describeVars $mode]
  375.     
  376.     set etext "\rMode-independent bindings:\r"
  377.     append text "\rMode-specific bindings:\r"
  378.     foreach b [split [bindingList] "\r"] {
  379.     set lst [lindex [split $b  " "] end]
  380.         if {$lst == $mode} {
  381.             append text "\t$b\r"
  382.         }
  383.     }
  384.     append text "\rTo list mode-independent bindings, select\
  385.       'List Global/All Bindings'\rfrom the Config menu.\r"
  386.     new -n "* <$mode> MODE *" -m Tcl -text $text -shell 1 -read-only 1
  387. }
  388.  
  389. proc mode::describeVars {pkg {pkgpref ""}} {
  390.     cache::readContents index::prefshelp
  391.     if {$pkgpref == ""} {set pkgpref $pkg}
  392.     global ${pkgpref}modeVars
  393.     append text "Package-specific variables:\r"
  394.     if {[array exists ${pkgpref}modeVars]} {
  395.     foreach v [lsort [array names ${pkgpref}modeVars]] {
  396.         set val [set ${pkgpref}modeVars($v)]
  397.         global flag::type
  398.         set description ""
  399.         if {[info exists prefshelp(${pkg},$v)]} {
  400.         set description [dialog::helpdescription $prefshelp(${pkg},$v)]
  401.         } elseif {[info exists prefshelp(${pkgpref},$v)]} {
  402.         set description [dialog::helpdescription $prefshelp(${pkgpref},$v)]
  403.         } elseif {[info exists prefshelp($v)]} {
  404.         set description [dialog::helpdescription $prefshelp($v)]
  405.         }
  406.         
  407.         if {$description != ""} {
  408.         regsub -all "\[\r\n\]" [breakIntoLines $description] "&  \# " description
  409.         append text "  # " $description "\r"
  410.         }
  411.         if {[info exists flag::type($v)] \
  412.           && [regexp {binding$} [set flag::type($v)]]} {
  413.         set val [dialog::specialView::binding $val]
  414.         }
  415.         append text [format "  %-20s: \"%s\"\r" $v $val]
  416.     }
  417.     }
  418.     
  419.     return $text
  420. }
  421.  
  422. # Now call the new proc dialog::pickMenusAndFeatures
  423.  
  424. proc mode::menus {} {mode::menusAndFeatures 1}
  425. proc mode::features {} {mode::menusAndFeatures 2}
  426. proc mode::menusAndFeatures {{mfb 0}} {
  427.     global mode
  428.     dialog::pickMenusAndFeatures $mode $mfb
  429. }
  430.  
  431. proc mode::getVar {var {aMode ""}} {
  432.     global mode
  433.     if {[string length $aMode] && ($aMode != $mode)} {
  434.     # Use aMode, which is not current mode
  435.     global ${aMode}modeVars
  436.     if {[info exists ${aMode}modeVars($var)]} {
  437.         return [set ${aMode}modeVars($var)]
  438.     } else {
  439.         global global::_varMem
  440.         if {[info exists global::_varMem($var)]} {
  441.         return [set global::_varMem($var)]
  442.         } else {
  443.         global $var
  444.         return [set $var]
  445.         }
  446.     }
  447.     } else {
  448.     # use current mode
  449.     global $var
  450.     return [set $var]
  451.     }
  452. }
  453.  
  454. if {[info tclversion] < 8.0} {
  455. proc mode::proc {name args} {
  456.     global mode
  457.     if {[info commands ${mode}::$name] != ""} {
  458.     eval ${mode}::$name $args
  459.     } else {
  460.     eval ::$name $args
  461.     }
  462. }
  463. proc mode::getProc {name} {
  464.     global mode
  465.     if {[info commands ${mode}::$name] != ""} {
  466.     return ${mode}::$name
  467.     } else {
  468.     return ""
  469.     }
  470. }
  471.  
  472. } else {
  473.     proc mode::proc {name args} {
  474.     global ::mode
  475.     namespace eval ::$mode "$name $args"
  476.     }
  477.     proc mode::getProc {name} {
  478.     global ::mode
  479.     namespace eval ::$mode "namespace which $name"
  480.     }
  481. }
  482.  
  483. # Suffixes used to determine mode for new windows.
  484. proc mode::updateSuffixes {} {
  485.     global ModeSuffixes filepats
  486.  
  487.     set ModeSuffixes [list default [list set winMode Text]]
  488.     foreach m [mode::listAll] {
  489.         if {[info exists filepats($m)]} {
  490.         lappend ModeSuffixes $filepats($m) [list set winMode $m]
  491.         }
  492.     }
  493. }
  494.  
  495. proc synchroniseModeVar {var args} {
  496.     global mode $var
  497.     if {[llength $args] > 0} {
  498.     set $var [lindex $args 0]
  499.     }
  500.     global ${mode}modeVars modifiedArrayElements
  501.     lappend modifiedArrayElements [list $var ${mode}modeVars]
  502.     set ${mode}modeVars($var) [set $var]
  503. }
  504.  
  505. # ◊◊◊◊ Miscellaneous ◊◊◊◊ #
  506.  
  507. proc alpha::actionOnFileScript {action file} {
  508.     global HOME
  509.     if {[file::pathStartsWith $file $HOME suffix]} {
  510.     append action " " "\[file join \"\$HOME\" \"$suffix\"\]"
  511.     } else {
  512.     lappend action $file
  513.     }
  514.     return $action
  515. }
  516.  
  517. proc alpha::tryToLoad {msg args} {
  518.     message "${msg}…"
  519.     set i -1
  520.     set ok 1
  521.     while 1 {
  522.     set do [lindex $args [incr i]]
  523.     set say [lindex $args [incr i]]
  524.     if {$say == ""} {
  525.         set say "Loading $do"
  526.     }
  527.     if {$do == ""} {
  528.         if {$ok} {
  529.         message "${msg}…Complete."
  530.         } else {
  531.         alertnote "${msg}…Failed."
  532.         }
  533.         return $ok
  534.     }
  535.     message "${say}…"
  536.     if {[catch $do err]} {
  537.         if {[dialog::yesno -y "View the error" -n "Continue" \
  538.           "$say failed!"]} {
  539.         global errorInfo
  540.         dialog::alert "$errorInfo"
  541.         }
  542.     }
  543.     }
  544. }
  545.  
  546. # ◊◊◊◊ Read in all the packages ◊◊◊◊ #
  547.  
  548. proc alpha::findAllPlugins {} {
  549.     # Execute pre-init code for each extension
  550.     if {[cache::exists index::preinit]} {
  551.     cache::readContents index::preinit
  552.     foreach f [array names index::preinit] {
  553.         set script [lindex [set index::preinit($f)] 1]
  554.         try::level \#0 $script -reporting log -while "pre-initialising $f" 
  555.     }
  556.     }
  557.     # Now pull in regular initialisation
  558.     alpha::findAllModes
  559.     global skipPrefs
  560.     if {!$skipPrefs} {
  561.     alpha::findAllExtensions
  562.     }
  563. }
  564.  
  565. proc alpha::findAllModes {} {
  566.     cache::readContents index::mode
  567.     foreach f [array names index::mode] {
  568.     eval addMode $f [lrange [set index::mode($f)] 1 3]
  569.     if {[string length [set script [lindex [set index::mode($f)] 4]]]} {
  570.         if {[catch {uplevel #0 $script} err]} {
  571.         lappend problems "$f"
  572.         }
  573.     }
  574.     }
  575.     if {[info exists problems]} {
  576.     alertnote "Problems loading modes: $problems"
  577.     }
  578.     mode::updateSuffixes
  579. }
  580.  
  581.  
  582.  
  583.  
  584.